
# Network Processes for Purl
# Basied on samplechat.pl script from Net::Server examples

package Purl::Network;
use strict;

use Purl::Config; 

no define NONE =>;

use base qw(Net::Server::Multiplex);
use Digest::MD5 qw(md5_base64);

###----------------------------------------------------------------###

# Demonstrate a Net::Server style hook
sub allow_deny_hook {
    my $self = shift;
    my $prop = $self->{server};
    my $sock = $prop->{client};

    return 1 if $prop->{peeraddr} =~ /^127\./;
    return 0;
}

# Another Net::Server style hook
sub request_denied_hook {
    print "Go away!\n";
    print STDERR "DEBUG: Client denied!\n";
}

# IO::Multiplex style callback hook
sub mux_connection {
    my $self = shift;
    my $mux  = shift;
    my $fh   = shift;
    my $peer = $self->{peeraddr};

    # Net::Server stores a connection counter in the {requests} field.
    #   $self->{id} = $self->{net_server}->{server}->{requests};

    # Keep some values that I might need while the {server}
    # property hash still contains the current client info
    # and stash them in my own object hash.
    $self->{peerport} = $self->{net_server}->{server}->{peerport};

    # Net::Server directs STDERR to the log_file
    print STDERR "DEBUG: Client [$peer] just connected...\n";

    # Notify everyone that the client arrived
    #   $self->broadcast( $mux, "JOIN: (#$self->{id}) from $peer\r\n" );

    # STDOUT is tie'd to the correct IO::Multiplex handle

#my $welcomeFile = config('mushdir') . "/" . config('welcomefile');
    my $welcomeText = Purl::comm::getFile(config('mushdir') . "/" . config('welcomefile'));


    print "$welcomeText\n";

    # At this point, drop the connection if they are idle at
    # the connect screen for more then 5 minutes
    $mux->set_timeout( $fh, 300 );

}

# If this callback is ever hooked, then the mux_connection callback
# is guaranteed to have already been run once (if defined).
sub mux_input {
    my $self   = shift;
    my $mux    = shift;
    my $fh     = shift;
    my $in_ref = shift;               # Scalar reference to the input
    my $peer   = $self->{peeraddr};
    my $id     = $self->{id};

    # Update the current time for this input/command pass.
    # This will be needed until a threaded timer module is implemented.
    $main::now = time;

    #   print STDERR "DEBUG: input from [$peer] ready for consuming.\n";

    # Process each line in the input, leaving partial lines
    # in the input buffer
    while ( $$in_ref =~ s/^(.*?)\r?\n// ) {
        next unless $1;
        my $text = $1;
        if ( ( exists $self->{id} ) && ( $self->{id} != NONE ) ) {

            # If there is an ID, this person has logged in.
            #print STDERR "DEBUG: command - $self->{id}, $text\n";

            
            # Update their idletime and reset the idle timer.
            $main::objects[ $self->{id} ]{"last"} = $main::now;
            $mux->set_timeout( $fh, undef );
            $mux->set_timeout( $fh, config("idletimeout") );
            #print STDERR "Timeout set to $main::idleTimeout\n";

            # So, we should check locally first, but we are waiting for the
            # new db first. This is so I don't forget that fact.. again.
            #
            Purl::Commands::run( $self->{id}, $text );

            #&command($self->{id}, $1 );

        }
        else {
            $mux->set_timeout( $fh, undef );
            $mux->set_timeout( $fh, 300 );

            $text =~ s/\s+/ /g;
            $text =~ s/^ //g;
            $text =~ s/ $//g;
            my ( $verb, $object, $pwd ) = split( / /, $text );
            #print STDERR "DEBUG: pre-login - $verb, $object, $pwd\n";

            return if ( $verb eq "" );
            if ( $verb =~ /^quit$/i ) {
                $fh->close();
                return;
            }
            if ( $verb =~ /^con/ ) {
                my $n = $object;
                $n =~ tr/A-Z/a-z/;
                if ( !exists( $main::playerIds{$n} ) ) {
                    print $fh "Login Failed\n";
                    print $fh "That player does not exist.\n";
                    return;
                }
                else {
                    my $id = $main::playerIds{$n};
                    if ( md5_base64($pwd) ne $main::objects[$id]{"password"} )
                    {
                        print $fh "Login Failed";
                        print $fh "That player has a different password.\n";
                        return;
                    }
                    $self->_playerLogout($id)
                        if ( $main::objects[$id]{"activeFd"} != NONE );
                    $self->{id} = $id;
                    $mux->set_timeout( $fh, undef );
                    $mux->set_timeout( $fh, config("idletimeout") );

                    $self->_playerLogin( $id, $fh );
                }
                return;
            }
            if ( $verb =~ /^cre/ ) {
                if ( substr( $object, 0, 1 ) eq "#" ) {
                    print "Sorry, names cannot begin with #.\n";
                    return;
                }
                $_ = $object;
                if (/\s/) {
                    print "Sorry, names cannot contain spaces.\n";
                    return;
                }
                my $n = $object;
                $n =~ tr/A-Z/a-z/;
                if ( exists( $main::playerIds{$n} ) ) {
                    print "Sorry, that name is taken.";
                    return;
                }
                my $id
                    = &Purl::database::addObject( 0, $object, $main::player );
                $main::playerIds{$n} = $id;
                $main::objects[$id]{"owner"} = $id;
                &Purl::database::addContents( 0, $id );
                $main::objects[$id]{"password"} = md5_base64($pwd);
                if (config("allowbuild")) {
                    $main::objects[$id]{"flags"}
                        = $main::flags{"builder"}{"value"};
                }
                else {
                    $main::objects[$id]{"flags"} = 0;
                }
                print "Player creation succeeded.\n";
                $self->{id} = $id;
                #print STDERR "Timeout set to $main::idleTimeout\n";
                $mux->set_timeout( $fh, undef );
                $mux->set_timeout( $fh, $main::idleTimeout );
                $self->_playerLogin( $id, $fh );
                return;
            }
            print "Try: connect <name> <password> (or quit)";
        }
    }
}

# It is possible that this callback will be called even
# if mux_connection or mux_input were never called.  This
# occurs when allow_deny or allow_deny_hook fails to
# authorize the client.  The callback object will be the
# default listen object instead of a client unique object.
# However, both object should contain the $self->{net_server}
# key pointing to the original Net::Server object.

sub mux_close {
    my $self = shift;
    my $mux  = shift;
    my $fh   = shift;
    my $peer = $self->{peeraddr};

    # If mux_connection has actually been run
    if ( exists $self->{id} ) {
        $self->_playerLogout( $self->{id} );
        print STDERR
            "DEBUG: Client [$peer] (id $self->{id}) closed connection!\n";
    }
}

# This callback will happen when the mux->set_timeout expires.
# The user has not issued any command in the allotted time and
# will be booted.

sub mux_timeout {
    my $self = shift;
    my $mux  = shift;
    my $fh   = shift;

    # Skip them if it's ok that they idle.
    return if ( Purl::tests::canIdle( $self->{id} ) );
    print $fh "Idle Timeout\n";
    $fh->close;
}

# Routine to send a message to all clients in a mux.
sub broadcast {
    my $self = shift;
    my $mux  = shift;
    my $msg  = shift;
    print STDERR "BROADCAST: $msg\n";
    foreach my $fh ( $mux->handles ) {

        # NOTE: All the client unique objects can be found at
        # $mux->{_fhs}->{$fh}->{object}
        # In this example, the {id} would be
        #   $mux->{_fhs}->{$fh}->{object}->{id}
        print $fh $msg . "\r\n";
    }
}

sub _playerLogin {
    my ( $self, $id, $fh ) = @_;
    $main::objects[$id]{"activeFd"} = $fh;
    $main::objects[$id]{"ip"}       = $self->{peeraddr};
    $main::objects[$id]{"site"}     = $self->{peerhost};
    $main::objects[$id]{"on"}       = $main::now;
    $main::objects[$id]{"last"}     = $main::now;
    $main::objects[$id]{"lastPing"} = $main::now;
    $main::objects[$id]{"location"} = 0
        if ( $main::objects[$id]{"location"} eq "" );
    print $fh "Login Succeeded\n";
    Purl::comm::_send_text_to_contents( $main::objects[$id]{"location"},
        NONE, $main::objects[$id]{"name"} . " has connected." )
        if (
        !(  $main::objects[ $main::objects[$id]{"location"} ]{"flags"}
            & $main::flags{"grand"}{"value"}
        )
        );
    Purl::comm::sendFile( $id, config("motdfile") );
    Purl::Commands::run( $id, "look" );
}

sub _playerLogout {
    my ( $self, $id ) = @_;
    my $fh = $main::objects[ $self->{id} ]{"activeFd"};
    print $fh "You have been logged out.\n";
    Purl::comm::_send_text_to_contents(
        $main::objects[ $self->{id} ]{"location"},
        NONE, $main::objects[ $self->{id} ]{"name"} . " has disconnected." );
    $main::objects[ $self->{id} ]{"activeFd"} = NONE;
    $main::objects[ $self->{id} ]{"ip"}       = NONE;
    $main::objects[ $self->{id} ]{"site"}     = NONE;
    $main::objects[ $self->{id} ]{"off"}      = $main::now;
    $self->{id}                               = NONE;
}

sub getActiveHandles {
    my @active = $main::server->{mux}->handles;
    return @active;
}

sub getActiveClients {
    my $fh;
    my @clients;
    my @active = $main::server->{mux}->handles;
    foreach $fh (@active) {
        my $id = $main::server->{mux}->{_fhs}->{$fh}->{object}->{id};
        next unless ( ($id) && ( $id != NONE ) );
        push @clients, $main::server->{mux}->{_fhs}->{$fh}->{object};
    }
    return @clients;
}

sub getClientFromHandle {
    my $fh = shift;
    return $main::server->{mux}->{_fhs}->{$fh}->{object};
}

sub closePlayerID {
    my $id = shift;
    $main::objects[$id]{"activeFd"}->close;
    return;
}

sub logoutPlayerID {
    my $id          = shift;
    my $fh          = $main::objects[$id]{"activeFd"};
    my $client      = getClientFromHandle($fh);
    my $welcomeText = Purl::comm::getFile(config("welcomefile"));
    $client->_playerLogout($id);
    print $fh "$welcomeText\n";
}

1;
